home *** CD-ROM | disk | FTP | other *** search
/ Meeting Pearls 4 / Meeting Pearls Vol. IV (1996)(GTI - Schatztruhe)[!].iso / Pearls / dev / Language / CLisp / defmacro.lsp < prev    next >
Lisp/Scheme  |  1996-04-15  |  30KB  |  719 lines
  1. ;;;; File DEFMACRO.LSP
  2. ;;; Macro DEFMACRO und einige Hilfsfunktionen für komplizierte Macros.
  3. ;;; 1. 9. 1988
  4. ;;; Adaptiert an DEFTYPE am 10.6.1989
  5.  
  6. (in-package "SYSTEM")
  7.  
  8. ;; Import aus CONTROL.Q:
  9.  
  10. #| (SYSTEM::PARSE-BODY body &optional docstring-allowed env)
  11.    expandiert die ersten Formen in der Formenliste body (im Macroexpansions-
  12.    Environment env), entdeckt dabei auftretende Deklarationen (und falls
  13.    docstring-allowed=T, auch einen Docstring) und liefert drei Werte:
  14.    1. body-rest, die restlichen Formen,
  15.    2. declspec-list, eine Liste der aufgetretenen Decl-Specs,
  16.    3. docstring, ein aufgetretener Docstring oder NIL.
  17. |#
  18. #| (SYSTEM::KEYWORD-TEST arglist kwlist)
  19.    testet, ob arglist (eine paarige Keyword/Value-Liste) nur Keywords
  20.    enthält, die auch in der Liste kwlist vorkommen, oder aber ein
  21.    Keyword/Value-Paar :ALLOW-OTHER-KEYS mit Value /= NIL enthält.
  22.    Wenn nein, wird ein Error ausgelöst.
  23. |#
  24. #| (keyword-test arglist kwlist) überprüft, ob in arglist (eine Liste
  25. von Keyword/Value-Paaren) nur Keywords vorkommen, die in kwlist vorkommen,
  26. oder ein Keyword/Value-Paar mit Keyword = :ALLOW-OTHER-KEYS und Value /= NIL
  27. vorkommt. Sollte dies nicht der Fall sein, wird eine Errormeldung ausgegeben.
  28.  
  29. (defun keyword-test (arglist kwlist)
  30.   (let ((unallowed-arglistr nil)
  31.         (allow-other-keys-flag nil))
  32.     (do ((arglistr arglist (cddr arglistr)))
  33.         ((null arglistr))
  34.       (if (eq (first arglistr) ':ALLOW-OTHER-KEYS)
  35.           (if (second arglistr) (setq allow-other-keys-flag t))
  36.           (do ((kw (first arglistr))
  37.                (kwlistr kwlist (cdr kwlistr)))
  38.               ((or (null kwlistr) (eq kw (first kwlistr)))
  39.                (if (and (null kwlistr) (null unallowed-arglistr))
  40.                    (setq unallowed-arglistr arglistr)
  41.     ) )   )   ))
  42.     (unless allow-other-keys-flag
  43.       (if unallowed-arglistr
  44.         (cerror 
  45.          #L{
  46.          DEUTSCH "Beide werden übergangen."
  47.          ENGLISH "It will be ignored."
  48.          FRANCAIS "Ignorer les deux."
  49.          }
  50.          #L{
  51.          DEUTSCH "Unzulässiges Keyword ~S mit Wert ~S"
  52.          ENGLISH "Invalid keyword-value-pair: ~S ~S"
  53.          FRANCAIS "Mot-clé illégal ~S, valeur ~S"
  54.          }
  55.          (first unallowed-arglistr) (second unallowed-arglistr)
  56.     ) ) )
  57. ) )
  58. ; Definition in Assembler siehe CONTROL.Q
  59. |#
  60.  
  61. (defun macro-call-error (macro-form)
  62.   (error-of-type 'program-error
  63.     #L{
  64.     DEUTSCH "Der Macro ~S kann nicht mit ~S Argumenten aufgerufen werden: ~S"
  65.     ENGLISH "The macro ~S may not be called with ~S arguments"
  66.     FRANCAIS "Le macro ~S ne peut pas être appelé avec ~S arguments : ~S"
  67.     }
  68.     (car macro-form) (1- (length macro-form)) macro-form
  69. ) )
  70.  
  71. (proclaim '(special
  72.         %restp ; gibt an, ob &REST/&BODY/&KEY angegeben wurde,
  73.                ; also ob die Argumentanzahl unbeschränkt ist.
  74.  
  75.         %min-args ; gibt die Anzahl der notwendigen Argumente an
  76.  
  77.         %arg-count ; gibt die Anzahl der Einzelargumente an
  78.                    ; (notwendige und optionale Argumente, zusammengezählt)
  79.  
  80.         %let-list ; umgedrehte Liste der Bindungen, die mit LET* zu machen sind
  81.  
  82.         %keyword-tests ; Liste der KEYWORD-TEST - Aufrufe, die einzubinden sind
  83.  
  84.         %default-form ; Default-Form für optionale und Keyword-Argumente,
  85.                    ; bei denen keine Default-Form angegeben ist.
  86.                    ; =NIL normalerweise, = (QUOTE *) für DEFTYPE.
  87. )          )
  88. #|
  89. (ANALYZE1 lambdalist accessexp name wholevar)
  90. analysiert eine Macro-Lambdaliste (ohne &ENVIRONMENT). accessexp ist der
  91. Ausdruck, der die Argumente liefert, die mit dieser Lambdaliste zu matchen
  92. sind.
  93.  
  94. (ANALYZE-REST lambdalistr restexp name)
  95. analysiert den Teil einer Macro-Lambdaliste, der nach &REST/&BODY kommt.
  96. restexp ist der Ausdruck, der die Argumente liefert, die mit diesem
  97. Listenrest zu matchen sind.
  98.  
  99. (ANALYZE-KEY lambdalistr restvar name)
  100. analysiert den Teil einer Macro-Lambdaliste, der nach &KEY kommt.
  101. restvar ist das Symbol, das die restlichen Argumente enthalten wird.
  102.  
  103. (ANALYZE-AUX lambdalistr name)
  104. analysiert den Teil einer Macro-Lambdaliste, der nach &AUX kommt.
  105.  
  106. (REMOVE-ENV-ARG lambdalist name)
  107. entfernt das Paar &ENVIRONMENT/Symbol aus einer Macro-Lambdaliste,
  108. liefert zwei Werte: die verkürzte Lambdaliste und das als Environment zu
  109. verwendende Symbol (oder die Lambdaliste selbst und NIL, falls &ENVIRONMENT
  110. nicht auftritt).
  111.  
  112. (MAKE-LENGTH-TEST symbol)
  113. kreiert aus %restp, %min-args, %arg-count eine Testform, die bei Auswertung
  114. anzeigt, ob der Inhalt der Variablen symbol als Aufruferform zum Macro
  115. dienen kann.
  116.  
  117. (MAKE-MACRO-EXPANSION macrodef)
  118. liefert zu einer Macrodefinition macrodef = (name lambdalist . body)
  119. 1. den Macro-Expander als Programmtext (FUNCTION ... (LAMBDA ...)),
  120. 2. name, ein Symbol,
  121. 3. lambdalist,
  122. 4. docstring (oder NIL, wenn keiner da).
  123.  
  124. (MAKE-MACRO-EXPANDERCONS macrodef)
  125. liefert zu einer Macrodefinition macrodef = (name lambdalist . body)
  126. das fürs FENV bestimmte Cons (SYSTEM::MACRO . expander).
  127. |#
  128.  
  129. (%proclaim-constant 'macro-missing-value (list 'macro-missing-value))
  130. ; einmaliges Objekt
  131.  
  132. (%putd 'analyze-aux
  133.   (function analyze-aux
  134.     (lambda (lambdalistr name)
  135.       (do ((listr lambdalistr (cdr listr)))
  136.           ((atom listr)
  137.            (if listr
  138.              (cerror 
  139.               #L{
  140.               DEUTSCH "Der Teil danach wird ignoriert."
  141.               ENGLISH "The rest of the lambda list will be ignored."
  142.               FRANCAIS "Ignorer ce qui suit."
  143.               }
  144.               #L{
  145.               DEUTSCH "Die Lambdaliste des Macros ~S enthält einen Punkt nach &AUX."
  146.               ENGLISH "The lambda list of macro ~S contains a dot after &AUX."
  147.               FRANCAIS "La liste lambda du macro ~S contient un point après &AUX."
  148.               }
  149.               name
  150.           )) )
  151.         (cond ((symbolp (car listr)) (setq %let-list (cons `(,(car listr) nil) %let-list)))
  152.               ((atom (car listr))
  153.                (error-of-type 'program-error
  154.                  #L{
  155.                  DEUTSCH "Im Macro ~S ist als &AUX-Variable nicht verwendbar: ~S"
  156.                  ENGLISH "in macro ~S: ~S may not be used as &AUX variable."
  157.                  FRANCAIS "Dans le macro ~S, l'utilisation de ~S n'est pas possible comme variable &AUX."
  158.                  }
  159.                  name (car listr)
  160.               ))
  161.               (t (setq %let-list
  162.                    (cons `(,(caar listr) ,(cadar listr)) %let-list)
  163.   ) ) ) )     )  )
  164. )
  165.  
  166. (%putd 'analyze-key
  167.   (function analyze-key
  168.     (lambda (lambdalistr restvar name &aux (otherkeysforbidden t) (kwlist nil))
  169.       (do ((listr lambdalistr (cdr listr))
  170.            (next)
  171.            (kw)
  172.            (svar)
  173.            (g))
  174.           ((atom listr)
  175.            (if listr
  176.              (cerror 
  177.               #L{
  178.               DEUTSCH "Der Teil danach wird ignoriert."
  179.               ENGLISH "The rest of the lambda list will be ignored."
  180.               FRANCAIS "Ignorer ce qui suit."
  181.               }
  182.               #L{
  183.               DEUTSCH "Die Lambdaliste des Macros ~S enthält einen Punkt nach &KEY."
  184.               ENGLISH "The lambda list of macro ~S contains a dot after &KEY."
  185.               FRANCAIS "La liste lambda du macro ~S contient un point après &KEY."
  186.               }
  187.               name
  188.           )) )
  189.         (setq next (car listr))
  190.         (cond ((eq next '&ALLOW-OTHER-KEYS) (setq otherkeysforbidden nil))
  191.               ((eq next '&AUX) (return-from nil (analyze-aux (cdr listr) name)))
  192.               ((or (eq next '&ENVIRONMENT) (eq next '&WHOLE) (eq next '&OPTIONAL)
  193.                    (eq next '&REST) (eq next '&BODY) (eq next '&KEY)
  194.                )
  195.                (cerror 
  196.                 #L{
  197.                 DEUTSCH "Es wird ignoriert."
  198.                 ENGLISH "It will be ignored."
  199.                 FRANCAIS "Ignorer ce qui suit."
  200.                 }
  201.                 #L{
  202.                 DEUTSCH "Die Lambdaliste des Macros ~S enthält ein ~S an falscher Stelle."
  203.                 ENGLISH "The lambda list of macro ~S contains a badly placed ~S."
  204.                 FRANCAIS "La liste lambda du macro ~S contient un ~S mal placé."
  205.                 }
  206.                 name next
  207.               ))
  208.               (t
  209.                 (if %default-form
  210.                   (cond ((symbolp next) (setq next (list next %default-form)))
  211.                         ((and (consp next) (eql (length next) 1))
  212.                          (setq next (list (car next) %default-form))
  213.                 ) )     )
  214.                 (cond ((symbolp next)
  215.                        (setq kw (intern (symbol-name next) *keyword-package*))
  216.                        (setq %let-list
  217.                          (cons `(,next (GETF ,restvar ,kw NIL)) %let-list)
  218.                        )
  219.                        (setq kwlist (cons kw kwlist))
  220.                       )
  221.                       ((atom next)
  222.                        (cerror 
  223.                         #L{
  224.                         DEUTSCH "Es wird ignoriert."
  225.                         ENGLISH "It will be ignored."
  226.                         FRANCAIS "Il sera ignoré."
  227.                         }
  228.                         #L{
  229.                         DEUTSCH "Die Lambdaliste des Macros ~S enthält folgendes unpassende Element: ~S"
  230.                         ENGLISH "The lambda list of macro ~S contains the invalid element ~S"
  231.                         FRANCAIS "La liste lambda du macro ~S contient cet élément inadmissible : ~S"
  232.                         }
  233.                         name next
  234.                       ))
  235.                       ((symbolp (car next))
  236.                        (setq kw (intern (symbol-name (car next)) *keyword-package*))
  237.                        (setq %let-list
  238.                          (cons `(,(car next) (GETF ,restvar ,kw MACRO-MISSING-VALUE))
  239.                                %let-list
  240.                        ) )
  241.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  242.                                     (third next)
  243.                                     nil
  244.                        )          )
  245.                        (setq %let-list
  246.                          (cons
  247.                            (if svar
  248.                              `(,svar (IF (EQ ,(car next) MACRO-MISSING-VALUE)
  249.                                        (PROGN (SETQ ,(car next) ,(cadr next)) NIL)
  250.                                        T
  251.                               )      )
  252.                              `(,(car next) (IF (EQ ,(car next) MACRO-MISSING-VALUE)
  253.                                              ,(cadr next)
  254.                                              ,(car next)
  255.                               )            )
  256.                            )
  257.                            %let-list
  258.                        ) )
  259.                        (setq kwlist (cons kw kwlist))
  260.                       )
  261.                       ((not (and (consp (car next)) (keywordp (caar next)) (consp (cdar next))))
  262.                        (cerror 
  263.                         #L{
  264.                         DEUTSCH "Es wird ignoriert."
  265.                         ENGLISH "It will be ignored."
  266.                         FRANCAIS "Elle sera ignorée."
  267.                         }
  268.                         #L{
  269.                         DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige Keywordspezifikation: ~S"
  270.                         ENGLISH "The lambda list of macro ~S contains an invalid keyword specification ~S"
  271.                         FRANCAIS "La liste lambda du macro ~S contient une spécification de mot-clé inadmissible : ~S"
  272.                         }
  273.                         name (car next)
  274.                       ))
  275.                       ((symbolp (cadar next))
  276.                        (setq kw (caar next))
  277.                        (setq %let-list
  278.                          (cons `(,(cadar next) (GETF ,restvar ,kw MACRO-MISSING-VALUE))
  279.                            %let-list
  280.                        ) )
  281.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  282.                                     (third next)
  283.                                     nil
  284.                        )          )
  285.                        (setq %let-list
  286.                          (cons
  287.                            (if svar
  288.                              `(,svar (IF (EQ ,(cadar next) MACRO-MISSING-VALUE)
  289.                                        (PROGN (SETQ ,(cadar next) ,(cadr next)) NIL)
  290.                                        T
  291.                               )      )
  292.                              `(,(cadar next) (IF (EQ ,(cadar next) MACRO-MISSING-VALUE)
  293.                                              ,(cadr next)
  294.                                              ,(cadar next)
  295.                               )            )
  296.                            )
  297.                            %let-list
  298.                        ) )
  299.                        (setq kwlist (cons kw kwlist))
  300.                       )
  301.                       (t
  302.                        (setq kw (caar next))
  303.                        (setq g (gensym))
  304.                        (setq %let-list
  305.                          (cons `(,g (GETF ,restvar ,kw MACRO-MISSING-VALUE)) %let-list)
  306.                        )
  307.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  308.                                     (third next)
  309.                                     nil
  310.                        )          )
  311.                        (setq %let-list
  312.                          (cons
  313.                            (if svar
  314.                              `(,svar (IF (EQ ,g MACRO-MISSING-VALUE)
  315.                                        (PROGN (SETQ ,g ,(cadr next)) NIL)
  316.                                        T
  317.                               )      )
  318.                              `(,g (IF (EQ ,g MACRO-MISSING-VALUE)
  319.                                     ,(cadr next)
  320.                                     ,(cadar next)
  321.                               )   )
  322.                            )
  323.                            %let-list
  324.                        ) )
  325.                        (setq kwlist (cons kw kwlist))
  326.                        (let ((%min-args 0) (%arg-count 0) (%restp nil) (%default-form nil))
  327.                          (analyze1 (cadar next) g name g)
  328.                       ))
  329.               ) )
  330.       ) )
  331.       (if otherkeysforbidden
  332.         (setq %keyword-tests
  333.           (cons `(KEYWORD-TEST ,restvar ',kwlist) %keyword-tests)
  334.       ) )
  335.   ) )
  336. )
  337.  
  338. (%putd 'analyze-rest
  339.   (function analyze-rest
  340.     (lambda (lambdalistr restexp name)
  341.       (if (atom lambdalistr)
  342.         (error-of-type 'program-error
  343.           #L{
  344.           DEUTSCH "Die Lambdaliste des Macros ~S enthält keine Variable nach &REST/&BODY."
  345.           ENGLISH "The lambda list of macro ~S is missing a variable after &REST/&BODY."
  346.           FRANCAIS "Il manque une variable après &REST/BODY dans la liste lambda du macro ~S."
  347.           }
  348.           name
  349.       ) )
  350.       (unless (symbolp (car lambdalistr))
  351.         (error-of-type 'program-error
  352.           #L{
  353.           DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige Variable nach &REST/&BODY: ~S"
  354.           ENGLISH "The lambda list of macro ~S contains an illegal variable after &REST/&BODY: ~S"
  355.           FRANCAIS "La liste lambda du macro ~S contient une variable indamissible après &REST/BODY : ~S"
  356.           }
  357.           name (car lambdalistr)
  358.       ) )
  359.       (let ((restvar (car lambdalistr))
  360.             (listr (cdr lambdalistr)))
  361.         (setq %restp t)
  362.         (setq %let-list (cons `(,restvar ,restexp) %let-list))
  363.         (cond ((null listr))
  364.               ((atom listr)
  365.                (cerror 
  366.                 #L{
  367.                 DEUTSCH "Der Teil danach wird ignoriert."
  368.                 ENGLISH "The rest of the lambda list will be ignored."
  369.                 FRANCAIS "Ignorer ce qui suit."
  370.                 }
  371.                 #L{
  372.                 DEUTSCH "Die Lambdaliste des Macros ~S enthält einen Punkt an falscher Stelle."
  373.                 ENGLISH "The lambda list of macro ~S contains a misplaced dot."
  374.                 FRANCAIS "La liste lambda du macro ~S contient un point mal placé."
  375.                 }
  376.                 name
  377.               ))
  378.               ((eq (car listr) '&KEY) (analyze-key (cdr listr) restvar name))
  379.               ((eq (car listr) '&AUX) (analyze-aux (cdr listr) name))
  380.               (t (cerror 
  381.                   #L{
  382.                   DEUTSCH "Dieser ganze Teil wird ignoriert."
  383.                   ENGLISH "They will be ignored."
  384.                   FRANCAIS "Ignorer cette partie."
  385.                   }
  386.                   #L{
  387.                   DEUTSCH "Die Lambdaliste des Macros ~S enthält überflüssige Elemente: ~S"
  388.                   ENGLISH "The lambda list of macro ~S contains superfluous elements: ~S"
  389.                   FRANCAIS "La liste lambda du macro ~S contient des éléments superflus : ~S"
  390.                   }
  391.                   name listr
  392.   ) ) ) )     )  )
  393. )
  394.  
  395. (%putd 'cons-car
  396.   (function cons-car
  397.     (lambda (exp &aux h)
  398.       (if
  399.         (and
  400.           (consp exp)
  401.           (setq h
  402.             (assoc (car exp)
  403.               '((car . caar) (cdr . cadr)
  404.                 (caar . caaar) (cadr . caadr) (cdar . cadar) (cddr . caddr)
  405.                 (caaar . caaaar) (caadr . caaadr) (cadar . caadar) (caddr . caaddr)
  406.                 (cdaar . cadaar) (cdadr . cadadr) (cddar . caddar) (cdddr . cadddr)
  407.                 (cddddr . fifth)
  408.         ) ) )  )
  409.         (cons (cdr h) (cdr exp))
  410.         (list 'car exp)
  411.   ) ) )
  412. )
  413.  
  414. (%putd 'cons-cdr
  415.   (function cons-cdr
  416.     (lambda (exp &aux h)
  417.       (if
  418.         (and
  419.           (consp exp)
  420.           (setq h
  421.             (assoc (car exp)
  422.               '((car . cdar) (cdr . cddr)
  423.                 (caar . cdaar) (cadr . cdadr) (cdar . cddar) (cddr . cdddr)
  424.                 (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) (caddr . cdaddr)
  425.                 (cdaar . cddaar) (cdadr . cddadr) (cddar . cdddar) (cdddr . cddddr)
  426.         ) ) )  )
  427.         (cons (cdr h) (cdr exp))
  428.         (list 'cdr exp)
  429.   ) ) )
  430. )
  431.  
  432. (%putd 'analyze1
  433.   (function analyze1
  434.     (lambda (lambdalist accessexp name wholevar)
  435.       (do ((listr lambdalist (cdr listr))
  436.            (withinoptional nil)
  437.            (item)
  438.            (g))
  439.           ((atom listr)
  440.            (when listr
  441.              (unless (symbolp listr)
  442.                (error-of-type 'program-error
  443.                  #L{
  444.                  DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige &REST-Variable: ~S"
  445.                  ENGLISH "The lambda list of macro ~S contains an illegal &REST variable: ~S"
  446.                  FRANCAIS "La liste lambda du macro ~S contient une variable &REST inadmissible : ~S"
  447.                  }
  448.                  name listr
  449.              ) )
  450.              (setq %let-list (cons `(,listr ,accessexp) %let-list))
  451.              (setq %restp t)
  452.           ))
  453.         (setq item (car listr))
  454.         (cond ((eq item '&WHOLE)
  455.                (if (and wholevar (cdr listr) (symbolp (cadr listr)))
  456.                  (progn
  457.                    (setq %let-list (cons `(,(cadr listr) ,wholevar) %let-list))
  458.                    (setq listr (cdr listr))
  459.                  )
  460.                  (error-of-type 'program-error
  461.                    #L{
  462.                    DEUTSCH "Die Lambdaliste des Macros ~S enthält ein unzulässiges &WHOLE: ~S"
  463.                    ENGLISH "The lambda list of macro ~S contains an invalid &WHOLE: ~S"
  464.                    FRANCAIS "La liste lambda du macro ~S contient un &WHOLE inadmissible : ~S"
  465.                    }
  466.                    name listr
  467.               )) )
  468.               ((eq item '&OPTIONAL)
  469.                (if withinoptional
  470.                  (cerror 
  471.                   #L{
  472.                   DEUTSCH "Es wird ignoriert."
  473.                   ENGLISH "It will be ignored."
  474.                   FRANCAIS "L'ignorer."
  475.                   }
  476.                   #L{
  477.                   DEUTSCH "Die Lambdaliste des Macros ~S enthält ein überflüssiges ~S."
  478.                   ENGLISH "The lambda list of macro ~S contains a superfluous ~S."
  479.                   FRANCAIS "La liste lambda du macro ~S contient un ~S superflu."
  480.                   }
  481.                   name item
  482.                ) )
  483.                (setq withinoptional t)
  484.               )
  485.               ((or (eq item '&REST) (eq item '&BODY))
  486.                (return-from nil (analyze-rest (cdr listr) accessexp name))
  487.               )
  488.               ((eq item '&KEY)
  489.                (setq g (gensym))
  490.                (setq %restp t)
  491.                (setq %let-list (cons `(,g ,accessexp) %let-list))
  492.                (return-from nil (analyze-key (cdr listr) g name))
  493.               )
  494.               ((eq item '&ALLOW-OTHER-KEYS)
  495.                (cerror 
  496.                 #L{
  497.                 DEUTSCH "Es wird ignoriert."
  498.                 ENGLISH "It will be ignored."
  499.                 FRANCAIS "L'ignorer."
  500.                 }
  501.                 #L{
  502.                 DEUTSCH "Die Lambdaliste des Macros ~S enthält ~S vor &KEY."
  503.                 ENGLISH "The lambda list of macro ~S contains ~S before &KEY."
  504.                 FRANCAIS "La liste lambda du macro ~S contient ~S avant &KEY."
  505.                 }
  506.                 name item
  507.               ))
  508.               ((eq item '&ENVIRONMENT)
  509.                (cerror 
  510.                 #L{
  511.                 DEUTSCH "Es wird ignoriert."
  512.                 ENGLISH "It will be ignored."
  513.                 FRANCAIS "L'ignorer."
  514.                 }
  515.                 #L{
  516.                 DEUTSCH "Die Lambdaliste des Macros ~S enthält ~S, was hier unzulässig ist."
  517.                 ENGLISH "The lambda list of macro ~S contains ~S which is illegal here."
  518.                 FRANCAIS "La liste lambda du macro ~S contient ~S qui est inadmissible ici."
  519.                 }
  520.                 name item
  521.               ))
  522.               ((eq item '&AUX)
  523.                (return-from nil (analyze-aux (cdr listr) name))
  524.               )
  525.               (withinoptional
  526.                (setq %arg-count (1+ %arg-count))
  527.                (if %default-form
  528.                  (cond ((symbolp item) (setq item (list item %default-form)))
  529.                        ((and (consp item) (eql (length item) 1))
  530.                         (setq item (list (car item) %default-form))
  531.                ) )     )
  532.                (cond ((symbolp item)
  533.                       (setq %let-list (cons `(,item ,(cons-car accessexp)) %let-list))
  534.                      )
  535.                      ((atom item)
  536.                       #1=
  537.                       (error-of-type 'program-error
  538.                         #L{
  539.                         DEUTSCH "Die Lambdaliste des Macros ~S enthält ein unzulässiges Element: ~S"
  540.                         ENGLISH "The lambda list of macro ~S contains an invalid element ~S"
  541.                         FRANCAIS "La liste lambda du macro ~S contient un élément inadmissible : ~S"
  542.                         }
  543.                         name item
  544.                      ))
  545.                      ((symbolp (car item))
  546.                       (setq %let-list
  547.                         (cons `(,(car item) (IF ,accessexp
  548.                                               ,(cons-car accessexp)
  549.                                               ,(if (consp (cdr item)) (cadr item) 'NIL)
  550.                                )            )
  551.                           %let-list
  552.                       ) )
  553.                       (when (and (consp (cdr item)) (consp (cddr item)))
  554.                         (unless (symbolp (caddr item))
  555.                           (error-of-type 'program-error
  556.                             #L{
  557.                             DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige supplied-Variable: ~S"
  558.                             ENGLISH "The lambda list of macro ~S contains an invalid supplied-variable ~S"
  559.                             FRANCAIS "La liste lambda du macro ~S contient une «supplied-variable» indamissible : ~S"
  560.                             }
  561.                             name (caddr item)
  562.                         ) )
  563.                         (setq %let-list
  564.                           (cons `(,(caddr item) (NOT (NULL ,accessexp))) %let-list)
  565.                      )) )
  566.                      (t
  567.                       (setq g (gensym))
  568.                       (setq %let-list
  569.                         (cons `(,g ,(if (consp (cdr item))
  570.                                       `(IF ,accessexp
  571.                                          ,(cons-car accessexp)
  572.                                          ,(cadr item)
  573.                                        )
  574.                                       (cons-car accessexp)
  575.                                )    )
  576.                           %let-list
  577.                       ) )
  578.                       (let ((%min-args 0) (%arg-count 0) (%restp nil))
  579.                         (analyze1 (car item) g name g)
  580.                       )
  581.                       (if (consp (cddr item))
  582.                         (setq %let-list
  583.                           (cons `(,(caddr item) (NOT (NULL ,accessexp))) %let-list)
  584.                )     )) )
  585.                (setq accessexp (cons-cdr accessexp))
  586.               )
  587.               (t ; notwendige Argumente
  588.                (setq %min-args (1+ %min-args))
  589.                (setq %arg-count (1+ %arg-count))
  590.                (cond ((symbolp item)
  591.                       (setq %let-list (cons `(,item ,(cons-car accessexp)) %let-list))
  592.                      )
  593.                      ((atom item)
  594.                       #1# ; (error-of-type ... name item), s.o.
  595.                      )
  596.                      (t
  597.                       (let ((%min-args 0) (%arg-count 0) (%restp nil))
  598.                         (analyze1 item (cons-car accessexp) name (cons-car accessexp))
  599.                )     ))
  600.                (setq accessexp (cons-cdr accessexp))
  601.   ) ) ) )     )
  602. )
  603.  
  604. (%putd 'remove-env-arg
  605.   (function remove-env-arg
  606.     (lambda (lambdalist name)
  607.       (do ((listr lambdalist (cdr listr)))
  608.           ((atom listr) (values lambdalist nil))
  609.         (if (eq (car listr) '&ENVIRONMENT)
  610.           (if (and (consp (cdr listr)) (symbolp (cadr listr)) (cadr listr))
  611.             ; &ENVIRONMENT gefunden
  612.             (return
  613.               (values
  614.                 (do ((l1 lambdalist (cdr l1)) ; lambdalist ohne &ENVIRONMENT/Symbol
  615.                      (l2 nil (cons (car l1) l2)))
  616.                     ((eq (car l1) '&ENVIRONMENT)
  617.                      (nreconc l2 (cddr l1))
  618.                 )   )
  619.                 (cadr listr)
  620.             ) )
  621.             (error-of-type 'program-error
  622.               #L{
  623.               DEUTSCH "In der Lambdaliste des Macros ~S muß nach &ENVIRONMENT ein Symbol (nicht NIL) folgen: ~S"
  624.               ENGLISH "In the lambda list of macro ~S, &ENVIRONMENT must be followed by a non-NIL symbol: ~S"
  625.               FRANCAIS "Dans la liste lambda du macro ~S, &ENVIRONMENT doit être suivi par un symbole autre que NIL : ~S"
  626.               }
  627.               name lambdalist
  628.           ) )
  629.   ) ) ) )
  630. )
  631.  
  632. (%putd 'make-length-test
  633.   (function make-length-test
  634.     (lambda (var &optional (header 1))
  635.       (cond ((and (zerop %min-args) %restp) NIL)
  636.             ((zerop %min-args) `(> (LENGTH ,var) ,(+ header %arg-count)))
  637.             (%restp `(< (LENGTH ,var) ,(+ header %min-args)))
  638.             ((= %min-args %arg-count) `(/= (LENGTH ,var) ,(+ header %min-args)))
  639.             (t `(NOT (<= ,(+ header %min-args) (LENGTH ,var) ,(+ header %arg-count))))
  640.   ) ) )
  641. )
  642.  
  643. (%putd 'make-macro-expansion
  644.   (function make-macro-expansion
  645.     (lambda (macrodef)
  646.       (if (atom macrodef)
  647.         (error-of-type 'program-error
  648.           #L{
  649.           DEUTSCH "Daraus kann kein Macro definiert werden: ~S"
  650.           ENGLISH "Cannot define a macro from that: ~S"
  651.           FRANCAIS "Aucun macro n'est définissable à partir de ~S"
  652.           }
  653.           macrodef
  654.       ) )
  655.       (unless (symbolp (car macrodef))
  656.         (error-of-type 'program-error
  657.           #L{
  658.           DEUTSCH "Der Name eines Macros muß ein Symbol sein, nicht: ~S"
  659.           ENGLISH "The name of a macro must be a symbol, not ~S"
  660.           FRANCAIS "Le nom d'un macro doit être un symbole et non ~S"
  661.           }
  662.           (car macrodef)
  663.       ) )
  664.       (if (atom (cdr macrodef))
  665.         (error-of-type 'program-error
  666.           #L{
  667.           DEUTSCH "Der Macro ~S hat keine Lambdaliste."
  668.           ENGLISH "Macro ~S is missing a lambda list."
  669.           FRANCAIS "Le macro ~S ne possède pas de liste lambda."
  670.           }
  671.           (car macrodef)
  672.       ) )
  673.       (let ((name (car macrodef))
  674.             (lambdalist (cadr macrodef))
  675.             (body (cddr macrodef))
  676.            )
  677.         (multiple-value-bind (body-rest declarations docstring)
  678.                              (parse-body body t) ; globales Environment!
  679.           (if declarations (setq declarations (list (cons 'DECLARE declarations))))
  680.           (multiple-value-bind (newlambdalist envvar)
  681.                                (remove-env-arg lambdalist name)
  682.             (let ((%arg-count 0) (%min-args 0) (%restp nil)
  683.                   (%let-list nil) (%keyword-tests nil) (%default-form nil))
  684.               (analyze1 newlambdalist '(CDR <MACRO-FORM>) name '<MACRO-FORM>)
  685.               (let ((lengthtest (make-length-test '<MACRO-FORM>))
  686.                     (mainform `(LET* ,(nreverse %let-list)
  687.                                  ,@declarations
  688.                                  ,@(nreverse %keyword-tests)
  689.                                  ,@body-rest
  690.                    ))          )
  691.                 (if lengthtest
  692.                   (setq mainform
  693.                     `(IF ,lengthtest
  694.                        (MACRO-CALL-ERROR <MACRO-FORM>)
  695.                        ,mainform
  696.                 ) )  )
  697.                 (values
  698.                   `(FUNCTION ,name
  699.                      (LAMBDA (<MACRO-FORM> &OPTIONAL ,(or envvar '<ENV-ARG>))
  700.                        (DECLARE (CONS <MACRO-FORM>))
  701.                        ,@(if envvar
  702.                            declarations ; enthält evtl. ein (declare (ignore envvar))
  703.                            '((DECLARE (IGNORE <ENV-ARG>)))
  704.                          )
  705.                        ,@(if docstring (list docstring))
  706.                        (BLOCK ,name ,mainform)
  707.                    ) )
  708.                   name
  709.                   lambdalist
  710.                   docstring
  711.   ) ) ) ) ) ) ) )
  712. )
  713.  
  714. (%putd 'make-macro-expandercons
  715.   (function make-macro-expandercons
  716.     (lambda (macrodef)
  717.       (cons 'MACRO (eval (make-macro-expansion macrodef)))
  718. ) ) )
  719.